home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / Perl Mode / perlEngine.tcl < prev    next >
Encoding:
Text File  |  1998-04-14  |  13.4 KB  |  557 lines  |  [TEXT/ALFA]
  1. # ◊◊◊◊ dummy to load file ◊◊◊◊ #
  2. proc perlEngine.tcl {} {}
  3.  
  4. #############################################################################
  5. # ◊◊◊◊ running scripts ◊◊◊◊ #
  6. # Tell MacPerl to run a script file:
  7. #
  8. proc perlExecuteFile {path {args {}} {flags {}}} {
  9.     global PerlmodeVars ALPHA scriptFile scriptStart filterHeadLen perlName
  10.     
  11.     if {[string length $path]} {
  12.         set perlName [file tail [app::launchBack McPL]]
  13.         if {[string length $perlName]} {
  14.                 
  15.             set ok [regexp {(.*):([^:]*)} $path pathname dirname filename]
  16.             if {!$ok} {    set name $wname    }
  17.  
  18.             if {$path != [scriptPath]} {    
  19.                 set filterHeadLen 0    
  20.             }
  21.             
  22.             if {$PerlmodeVars(perluseDebugger)} {
  23.                 append flags "debug"
  24.             }
  25.             if {$PerlmodeVars(perlpromptForArgs)} { 
  26.                 append args " [getCmdlineArgs]"
  27.             }
  28.             
  29.             sendCloseWinName $perlName $perlName
  30.             sendCloseWinName $perlName "Perl Debug"
  31.             if {$PerlmodeVars(perlautoSwitch) || $PerlmodeVars(perluseDebugger)} {
  32.                 switchTo $perlName
  33.             } else {
  34.                 message "Running file \"$filename\" as Perl script"
  35.                 watchCursor
  36.             }
  37.             
  38.             perlDoScript $perlName $path $args {} $flags
  39.             
  40. # (not sure which choice is better...)
  41. #            if {!$PerlmodeVars(perlautoSwitch)} {switchTo $ALPHA}
  42.             switchTo $ALPHA
  43. #
  44.             if {![getMacPerlError]} {
  45.                 if {$PerlmodeVars(perlretrieveOutput)} {openPerlOutput}
  46.             }
  47.         } else {
  48.             alertnote "Couldn't run MacPerl"
  49.         }
  50.     } else {
  51.         alertnote "No file specified to execute"
  52.     }
  53. }
  54.  
  55. #############################################################################
  56. # Run a MacPerl script, passed explicitly as a string:
  57. #
  58. # If no "#!/bin/perl" line already exists, one is preprended to the script
  59. # by wrapSelectScript, which also sets $filterHeadLen for use by 
  60. # getMacPerlError.
  61. # 
  62. proc perlExecuteScript {script {args ""} {flags {}} } {
  63.     global PerlmodeVars perlName
  64.     global scriptFile scriptStart filterHeadLen  ALPHA
  65.     
  66.     if {$script != ""} {
  67.         set script [wrapSelectScript $script]
  68.         
  69.         if {![regexp {(.*):([^:]*)} $scriptFile pathname dirname filename]} {
  70.             set filename $scriptFile 
  71.         }
  72.  
  73.         set perlName [file tail [app::launchBack McPL]]
  74.         if {[string length $perlName]} {
  75.         
  76.             if {$PerlmodeVars(perluseDebugger)} {
  77.                 append flags "debug"
  78.             }
  79.             if {$PerlmodeVars(perlpromptForArgs)} { 
  80.                 append args " [getCmdlineArgs]"
  81.             }
  82.             
  83.             sendCloseWinName $perlName $perlName
  84.             sendCloseWinName $perlName "Perl Debug"
  85.             if {$PerlmodeVars(perlautoSwitch) || $PerlmodeVars(perluseDebugger)} {
  86.                 switchTo $perlName
  87.             } else {
  88.                 message "Running buffer \"$filename\" as Perl script"
  89.                 watchCursor
  90.             }
  91.             
  92.             perlDoScript $perlName $script $args {} $flags
  93.             
  94.             switchTo $ALPHA
  95.  
  96.             if {![getMacPerlError]} {
  97.                 if {$PerlmodeVars(perlretrieveOutput)} {openPerlOutput}
  98.             }
  99.         }
  100.         
  101.     } else {
  102.             alertnote "Can't run an empty script"
  103.     }
  104. }
  105.  
  106. #############################################################################
  107. # Run a MacPerl script from the Tcl shell
  108. #
  109. # This proc pretends it is the invocation of the perl app when used 
  110. # as the first word of a command in the Tcl shell. -trf
  111. # 
  112. proc perl {{path {}} {args {}} } {
  113.     global PerlmodeVars ALPHA scriptFile scriptStart filterHeadLen perlName
  114.     set flags {}
  115.     
  116.     if {[string length $path]} {
  117.         set perlName [file tail [app::launchBack McPL]]
  118.         if {[string length $perlName]} {
  119.                 
  120.             set filename [file tail $path]
  121.             if {$path != [scriptPath]} {    
  122.                 set filterHeadLen 0    
  123.             }
  124.             
  125.             sendCloseWinName $perlName $perlName
  126.             sendCloseWinName $perlName "Perl Debug"
  127.             if {$PerlmodeVars(perlautoSwitch) || $PerlmodeVars(perluseDebugger)} {
  128.                 switchTo $perlName
  129.             } else {
  130.                 message "Running file \"$filename\" as Perl script"
  131.                 watchCursor
  132.             }
  133.             
  134.             perlDoScript $perlName $path $args {} $flags
  135.             
  136.             switchTo $ALPHA
  137.  
  138.             if {![getMacPerlError]} {
  139.                 if {$PerlmodeVars(perlretrieveOutput)} {openPerlOutput}
  140.             }
  141.         } else {
  142.             alertnote "Couldn't run MacPerl"
  143.         }
  144.     } else {
  145.         echo {Usage:  perl <filename> [ <args> ]}
  146.     }
  147. }
  148.  
  149.  
  150. # ◊◊◊◊ check MacPerl error msg ◊◊◊◊ #
  151. #############################################################################
  152. # Check the MacPerl output window for error messages.
  153. #
  154. proc getMacPerlError {} {
  155.     
  156.     set diag [getPerlDiag 40]
  157.     set errf [parseDiagErrf $diag]
  158.     set srcs [parseDiagSrcs $diag]
  159.     set mesg [parseDiagMesg $diag]
  160.  
  161.     if {[string length $errf]} {
  162.         showPerlDiag $diag [string length $diag] $mesg $errf $srcs
  163.         gotoPerlError $errf $srcs $mesg
  164.         return 1
  165.         
  166.     } else {
  167.         return 0
  168.     }
  169. }
  170.  
  171. #############################################################################
  172. # Check the MacPerl batch reply for error messages.
  173. #
  174. proc getBatchError {reply} {
  175.     global PerlmodeVars
  176.     set perlErrorWindow {* Perl Error Messages *}
  177.     
  178.     set fatalError 0
  179.     set diag [parseReplyDiag $reply]
  180.     set errf [parseDiagErrf  $diag ]
  181.     set srcs [parseReplySrcs $reply]
  182.     set mesg [parseDiagMesg  $diag ]
  183.     set errn [parseReplyErrn $reply]
  184.  
  185.     if {$errn} {        
  186.         showPerlDiag $diag $errn $mesg $errf $srcs
  187.         gotoPerlError $errf $srcs $mesg
  188.         set fatalError 1
  189.         
  190.     } elseif {[string length $diag] > 0} {
  191.         showPerlDiag $diag $errn $mesg $errf $srcs
  192.     }
  193.     
  194.     return $fatalError
  195. }
  196.  
  197. # ◊◊◊◊ get or show diag/errors ◊◊◊◊ #
  198.  
  199. #############################################################################
  200. # Display the Perl diagnostic output in its own window.
  201. #
  202. proc showPerlDiag {diag {errn 1} {mesg {}} {errf {}} {srcs {}}} {
  203.         global PerlmodeVars    
  204.         set perlErrorWindow {* Perl Error Messages *}
  205.         
  206.         set currWin [lindex [winNames] 0]
  207.         if {[lsearch [winNames] $perlErrorWindow] >= 0} {
  208.             bringToFront $perlErrorWindow
  209.             setWinInfo read-only 0
  210.             deleteText 0 [maxPos] 
  211.             insertText $diag
  212.         } else {
  213.             new -n $perlErrorWindow 
  214.              insertText $diag
  215.         }
  216.         
  217.         catch {shrinkWindow 2}
  218.         winReadOnly
  219.         bringToFront $currWin
  220. }
  221.  
  222. #############################################################################
  223. # Bring up a window containing the bug-ridden Perl code and highlight the
  224. # line at which the error was found.
  225. #
  226. proc gotoPerlError {errf srcs {mesg {}}} {
  227.     global PerlmodeVars scriptFile scriptStart filterHeadLen
  228.  
  229.     if {$errf == [scriptPath] || $errf == "<AppleEvent>"} {
  230.         set errf $scriptFile
  231.         # Convert it to the line number in the original file
  232.         set srcs [expr $srcs + $scriptStart - $filterHeadLen - 1]
  233.     }
  234.     # ... and leave an informative error message
  235.     #
  236.     if {[string length $mesg]} {
  237.         set mesg "$mesg at Line $srcs"            
  238.     } else {
  239.         set mesg "MacPerl flagged an error at Line $srcs"    
  240.     }
  241.     
  242.     # Bring up the script file and highlight the flagged line
  243.     #
  244.     catch {gotoFileLine $errf $srcs $mesg} fname    
  245. }
  246.  
  247. #############################################################################
  248. # Read the first block of lines (up to a maximum number) from the MacPerl
  249. # output window.
  250. #
  251. proc getPerlDiag {maxlines} {
  252.     global PerlmodeVars perlName
  253.     set pat0 {^[ \t]*$}
  254.  
  255.     set lines {}    
  256.  
  257.     # read first $maxlines of output to the MacPerl window
  258.     # (faster, but assumes error message won't appear at 
  259.     # the end of a lot of output).
  260.     #
  261.     set nlines [sendCountLines $perlName MacPerl]
  262.     set nlines [expr ($nlines > $maxlines)?$maxlines:$nlines]
  263.     if {$nlines > 0} {
  264.         set output [sendGetText $perlName $perlName 1 $nlines]
  265.         
  266.         foreach line [split $output "\r"] {
  267.             if  {[regexp $pat0 $line mtch]} {
  268.                 break
  269.             } else {
  270.                 append lines "$line\n"
  271.             }
  272.         }
  273.     }
  274.     return $lines
  275. }
  276.  
  277. # ◊◊◊◊ DoScript helpers ◊◊◊◊ #
  278.  
  279. #############################################################################
  280. # translate special DoScript flags into flags string $usrf
  281. #
  282. proc perlScriptFlags {{flags {}}} {
  283.      set usrf {}
  284.  
  285.     if {[lsearch -exact $flags "extract"] >= 0} {
  286.         append usrf { "EXTR" 'true'}
  287.     } elseif {[lsearch -exact $flags "noextract"] >= 0} {
  288.         append usrf { "EXTR" 'fals'}
  289.     }        
  290.     if {[lsearch -exact $flags "debug"] >= 0} {
  291.         append usrf { "DEBG" 'true'}
  292.     } elseif {[lsearch -exact $flags "nodebug"] >= 0} {
  293.         append usrf { "DEBG" 'fals'}
  294.     }        
  295.  
  296.     if {[lsearch -exact $flags "local"] >= 0} {
  297.         append usrf { "MODE" 'LOCL'}
  298.     } elseif {[lsearch -exact $flags "batch"] >= 0} {
  299.         append usrf { "MODE" 'BATC'}
  300.     } elseif {[lsearch -exact $flags "remote"] >= 0} {
  301.         append usrf { "MODE" 'RCTL'}
  302.     }        
  303.     return $usrf
  304. } 
  305.  
  306. proc perlScriptArgs {{args {}} {fileargs {}}} {
  307.     set nargs 0
  308.     set argv {}
  309.     
  310.     foreach item [parseWords $args] {
  311.         set item [string trim $item]
  312.         if {[string length $item]} {
  313.             append argv ", [curlyq $item]"
  314.             incr nargs
  315.         }
  316.     }
  317.     foreach filename $fileargs {
  318.         set item [string trim $filename]
  319.         if {[string length $item]} {
  320.             append argv ", [curlyq $item]"
  321.             incr nargs
  322.         }
  323.     }
  324.     return $argv
  325. }
  326.  
  327. #############################################################################
  328. # General Apple Event routines
  329. # (most of these have been moved to Modes:appleEvents.tcl)
  330. #
  331.  
  332.  
  333. #############################################################################
  334. # DoScript for MacPerl 4.1.3
  335. # (runs in "Local" mode under v4.1.4+)
  336. #
  337. proc perlDoScript {appname script {args {}} {fileargs {}} {flags {}} } {
  338.     # form list of quoted "command-line" args
  339.     #
  340.     if {$script != ""} {
  341.         set argv "\[[curlyq [string trim $script]]"
  342.         append argv [perlScriptArgs $args $fileargs]
  343.         append argv "]"
  344.         
  345.         set usrf [perlScriptFlags $flags]
  346.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc $usrf \"----\" [list $argv] "]
  347.     #    alertnote $reply
  348.     }
  349. }
  350.  
  351. # DoScript for MacPerl 4.1.4+
  352. # 
  353. # [Q] do I need this for perl via shell? -trf
  354. #
  355. proc perlDoScriptBatch {appname script {args {}} {fileargs {}}} {
  356.     
  357.     # form list of quoted "command-line" args
  358.     #
  359.     if {$script != ""} {
  360.         set argv "\[[curlyq [string trim $script]]"
  361.         append argv [perlScriptArgs $args $fileargs ] 
  362.         append argv "]"
  363.                 
  364.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE BATC \"----\" [list $argv]"]
  365.         
  366. #         perlDisplayReply $reply
  367.  
  368.     } else {
  369.         set reply {}
  370.     }
  371.     return $reply
  372. }
  373.  
  374. # For debugging 
  375. #
  376. proc perlDisplayReply {reply} {
  377.     set currWin [lindex [winNames] 0]
  378.     new -n {*** DoScript Reply **} 
  379.     insertText $reply
  380.         
  381.     winReadOnly
  382.     catch {shrinkWindow 2}
  383.     bringToFront $currWin
  384. }
  385.  
  386. # DoScript to launch interactive debugger (for MacPerl 4.1.4+)
  387. #
  388. proc perlDoScriptDebug {appname script {args {}} {fileargs {}}} {
  389.     
  390.     # form list of quoted "command-line" args
  391.     #
  392.     if {$script != ""} {
  393.         set argv "\[[curlyq [string trim $script]]"
  394.         append argv [perlScriptArgs "$args debug" $fileargs ] 
  395.         append argv "]"
  396.                 
  397.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE RCTL \"----\" [list $argv]"]
  398.  
  399.         new -n {** DoScriptDebug Reply **} 
  400.         insertText $reply
  401.             
  402.         winReadOnly
  403.         catch {shrinkWindow 2}
  404.  
  405.     } else {
  406.         set reply {}
  407.     }
  408.     return $reply
  409. }
  410.  
  411. # ◊◊◊◊ parse MacPerl output ◊◊◊◊ #
  412.  
  413. #############################################################################
  414. # Extract various items out of the MacPerl diagnostic output
  415. #
  416.  
  417. # Name of the file in which the error was found
  418. #
  419. proc parseDiagErrf {diag}    {
  420.     if {![regexp {File '([^']+)'; Line} $diag allofit errf]} { 
  421.         set errf {}
  422.     }
  423.     return $errf
  424. }
  425.  
  426. # The line number on which the error was found
  427. #
  428. proc parseDiagSrcs {diag}    {
  429.     if {![regexp {File '[^']+'; Line ([0-9]+)} $diag allofit srcs]} { 
  430.         set srcs 0 
  431.     }
  432.     return $srcs
  433. }
  434.  
  435. # The error message associated with error
  436. #
  437. proc parseDiagMesg {diag} {
  438.     set pat1 {^#(.*)$}
  439.     set pat2 {File '([^']+)'; Line ([0-9]+)}
  440.     
  441.     set errMessage {}
  442.     set errFound 0
  443.     
  444.     foreach line [split $diag "\n"] {
  445.         if {[regexp $pat2 $line mtch num]} {
  446.             set errFound 1
  447.         } elseif {[regexp $pat1 $line mtch err]} {
  448.             if {$errFound == 0} {
  449.                 set errMessage $err
  450.             }
  451.         }
  452.     }
  453.     return $errMessage
  454. }
  455.  
  456. #############################################################################
  457. # Extract various return parameters out of a MacPerl DoScript reply
  458. #
  459.  
  460. # Result from batch script
  461. #
  462. proc parseReplyResult {reply} {
  463.     if {![regexp {'?\-\-\-\-'?:“([^”]*)”} $reply allofit result]} { 
  464.         set result {}
  465.     }
  466.     return $result
  467. }
  468.  
  469. # Standard output of batch script
  470. #
  471. proc parseReplyOutp {reply} {
  472.     if {![regexp {OUTP:“([^”]*)”} $reply allofit outp]} { 
  473.         set outp {}
  474.     }
  475.     return $outp
  476. }
  477.  
  478. # Diagnostic output of the batch script
  479. #
  480. proc parseReplyDiag {reply}    {
  481.     if {[regexp {diag:“([^”]*)”} $reply allofit diag]}  {
  482.     } else { 
  483.         set diag {}
  484.     }
  485.     return $diag
  486. }
  487.  
  488. # File alias of the script file in which the error was found
  489. #
  490. proc parseReplyErob {reply}    {
  491.     if {![regexp {erob:alis\(«(.*)»\)} $reply allofit erob]} {
  492.         set erob {} 
  493.     }
  494.     return $erob
  495. }
  496.  
  497. # First line flagged in error
  498. #
  499. proc parseReplySrcs {reply}    {
  500.     if {![regexp {erng:{srcs:([0-9]+)[^\}]*}} $reply allofit srcs]} { 
  501.         set srcs 0 
  502.     }
  503.     return $srcs
  504. }
  505.  
  506. # Last line flagged in error
  507. #
  508. proc parseReplySrce {reply}    {
  509.     if {![regexp {erng:{[^\}]*srce:([0-9]+)}} $reply allofit srce]} { 
  510.         set srce 0
  511.     }
  512.     return $srce
  513. }
  514.  
  515. # Error number
  516. #
  517. proc parseReplyErrn {reply}    {
  518.     if {![regexp {errn:([0-9]+)} $reply allofit errn]} {
  519.         set errn 0
  520.     }
  521.     return $errn
  522. }
  523.  
  524. #############################################################################
  525. # Read the MacPerl output window and load the contents, if any, into
  526. # a new Alpha window. 
  527. # 
  528. # Modified to direct output to Tcl Shell if perl was called from there -trf
  529. #
  530. proc openPerlOutput {} {
  531.     global PerlmodeVars perlRecycleOutput perlName
  532.     set perlOutputWindow {* Perl Output *}
  533.     
  534.     set output [sendGetText $perlName $perlName]
  535.     if {[string length $output]} {
  536.         if {[win::CurrentTail] == "*tcl shell*"} {
  537.             endOfBuffer
  538.             insertText \r $output
  539.             endOfBuffer 
  540.         } elseif {$PerlmodeVars(perlRecycleOutput) && 
  541.             [lsearch [winNames] $perlOutputWindow] >= 0} {
  542.             
  543.             bringToFront $perlOutputWindow
  544.             replaceText [minPos] [maxPos] $output
  545.             catch {shrinkWindow 2}
  546.             setWinInfo dirty 0
  547.             goto [minPos]
  548.         } else {
  549.             new -n $perlOutputWindow
  550.             insertText $output
  551.             catch {shrinkWindow 2}
  552.             setWinInfo dirty 0
  553.             goto [minPos]
  554.         }
  555.     }
  556. }
  557.